home *** CD-ROM | disk | FTP | other *** search
/ 8bitfiles.net/archives / archives.tar / archives / compuserve-file-archive / 22 Graphics & Utilities / PAINTP.DOC < prev    next >
Encoding:
Text File  |  2019-04-13  |  4.3 KB  |  207 lines
  1. program paintpix (input,output);
  2. (*pgm. to load & display the paintpic pictures*)
  3. (*adapted from the paintpic basic display pgm.*)
  4. (*by david r. pounds*)
  5. (*update 1/1/86*)
  6. (*artwork is by alan m. pounds*)
  7.  
  8. const clear=147;
  9. var choice:char;
  10.     bkgcolr:integer;
  11.  
  12. function getnumb:integer;
  13. var next:char;
  14.     infile:text;
  15. begin
  16.  read(infile,next);
  17.  getnumb:=ord(next)
  18. end;(*getnumb*)
  19.  
  20. function pokeit (address:integer):integer;
  21. var value,change,lobit,hibit,addr,poke:integer;
  22. begin
  23.  value:=getnumb;
  24.  lobit:=getnumb;
  25.  hibit:=getnumb;
  26.  change:=256*hibit+lobit;
  27.  for addr:=0 to change-1
  28.  do begin
  29.   poke:=address+addr;
  30.   mem [poke]:=chr(value)
  31.  end;(*addr do*)
  32.  pokeit:=address+change
  33. end;(*pokeit*)
  34.  
  35. function picload (picname:string):integer;
  36. const coloram=$d800;
  37.       bkgaddr=$5c00;
  38.       picaddr=$6000;
  39. var first:char;
  40.     infile:text;
  41.     address:integer;
  42. begin
  43.  reset(infile,picname);
  44.  read(infile,first);
  45.  if not (first='p') then exit(picload);
  46.  picload:=getnumb;
  47.  address:=coloram;
  48.  repeat
  49.   address:=pokeit (address)
  50.  until (address > coloram+999);
  51.  address:=bkgaddr;
  52.  repeat
  53.   address:=pokeit (address)
  54.  until (address > bkgaddr+999);
  55.  address:=picaddr;
  56.  repeat
  57.   address:=pokeit (address)
  58.  until (address > picaddr+7999);
  59.  close(infile)
  60. end;(*picload*)
  61.  
  62. procedure bitmapset (bkgcolr:integer);
  63. const screenset=$d018;
  64.       bitmaptog=$d011;
  65.       multicolr=$d016;
  66.       bkgrcolor=$d021;
  67.       bankselct=$dd02;
  68.       bankchang=$dd00;
  69. var toggle:integer;
  70. begin
  71.  mem [screenset]:=chr(120);
  72.  toggle:=ord(mem [bitmaptog]);
  73.  toggle:=orb(toggle,32);
  74.  mem [bitmaptog]:=chr(toggle);
  75.  toggle:=ord(mem [multicolr]);
  76.  toggle:=orb(toggle,16);
  77.  mem [multicolr]:=chr(toggle);
  78.  mem [bkgrcolor]:=chr(bkgcolr);
  79.  toggle:=ord(mem [bankselct]);
  80.  toggle:=orb(toggle,3);
  81.  mem [bankselct]:=chr(toggle);
  82.  toggle:=ord(mem [bankchang]);
  83.  toggle:=andb(toggle,252);
  84.  toggle:=orb(toggle,2);
  85.  mem [bankchang]:=chr(toggle)(* 1 *)
  86. end;(*bitmapset*)
  87.  
  88. procedure backtotext;
  89. const screenset=$d018;
  90.       bitmaptog=$d011;
  91.       multicolr=$d016;
  92.       bkgrcolor=$d021;
  93.       bankselct=$dd02;
  94.       bankchang=$dd00;
  95.       blue=6;
  96. var toggle:integer;
  97. begin
  98.  mem [screenset]:=chr(21);
  99.  toggle:=ord(mem [bitmaptog]);
  100.  toggle:=andb(toggle,223);
  101.  mem [bitmaptog]:=chr(toggle);
  102.  toggle:=ord(mem [multicolr]);
  103.  toggle:=andb(toggle,239);
  104.  mem [multicolr]:=chr(toggle);
  105.  mem [bkgrcolor]:=chr(blue);
  106.  toggle:=ord(mem [bankselct]);
  107.  toggle:=orb(toggle,3);
  108.  mem [bankselct]:=chr(toggle);
  109.  toggle:=ord(mem [bankchang]);
  110.  toggle:=andb(toggle,252);
  111.  toggle:=orb(toggle,3);
  112.  mem [bankchang]:=chr(toggle)(* 0 *)
  113. end;(*backtotext*)
  114.  
  115. procedure listpix;
  116. begin
  117.  write(chr(clear));
  118.  writeln;
  119.  writeln('these are the picture titles');
  120.  writeln;writeln;
  121.  writeln('shuttle');writeln;
  122.  writeln('starship');writeln;
  123.  writeln('knight');writeln;
  124.  writeln('earthrise #1');writeln;
  125.  writeln('saturn #2');writeln;
  126.  writeln('saturnport 3');writeln;
  127. end;(*listpix*)
  128.  
  129. function nameok (name:string):boolean;
  130. var next:char;
  131.     letter:1..16;
  132. begin
  133.  if length(name)<=16
  134.  then begin
  135.   nameok:=true;
  136.   for letter:=1 to length(name)
  137.   do begin
  138.    next:=copy(name,letter,1);
  139.    if (next='?') or (next='*')
  140.    then nameok:=false
  141.   end(*letter for*)
  142.  end(*length then*)
  143.  else nameok:=false
  144. end;(*nameok*)
  145.  
  146. function choosepic (from:string):string [16];
  147. var name:string;
  148. begin
  149.  writeln;
  150.  listpix;
  151.  writeln;
  152.  writeln('what picture do you want to ',from,' ?');
  153.  writeln;
  154.  repeat
  155.   writeln('it must be 16 characters or less');
  156.   writeln('and contain no ? or *');
  157.   writeln;
  158.   readln(name)
  159.  until nameok (name);
  160. choosepic:=name
  161. end;(*choosepic*)
  162.  
  163. function loader:integer;
  164. var from:string;
  165.     picname:string [16];
  166. begin
  167.  write(chr(clear));
  168.  from:='load';
  169.  picname:=choosepic (from);
  170.  write(chr(clear));
  171.  writeln('loading ',picname,' from disk');
  172.  loader:=picload (picname)
  173. end;(*loader*)
  174.  
  175. procedure viewpic (bkgcolr:integer);
  176. var dummy:char;
  177. begin
  178.  writeln('press f7 to get back to menu');
  179.  writeln;
  180.  writeln('return to continue');
  181.  readln(dummy);
  182.  bitmapset (bkgcolr);
  183.  if (inkey=chr(136))
  184.  then backtotext
  185. end;(*viewpic*)
  186.  
  187. begin (*main*)
  188.  write(chr(clear));
  189.  repeat
  190.   write(chr(clear));
  191.   writeln;
  192.   writeln('do you want to load a picture');
  193.   writeln('from the disk ? (l)');
  194.   writeln;
  195.   writeln('view loaded picture ? (v)');
  196.   writeln;
  197.   writeln('or quit ? (q)');
  198.   writeln;
  199.   readln(choice);
  200.   writeln;
  201.   case choice of
  202.    'l':bkgcolr:=loader;
  203.    'v':viewpic (bkgcolr)
  204.   end(*choice case*)
  205.  until choice='q'
  206. end.(*paintpix*)
  207.